Stichprobenverteilung und Schätzung mittels (Re-)Sampling

Prof. Dr. Jörg Schoder

2023-05-29

Urnenmodell

Quelle: moderndive.com

Zufallsexperiment und Stichprobenziehung

Stichprobenziehung

Ergebnis einer Stichprobe

Ergebnis mehrerer Stichproben

Datensatz zum physischen Experiment

library(moderndive)
tactile_prop_red
## # A tibble: 33 × 4
##    group            replicate red_balls prop_red
##    <chr>                <int>     <int>    <dbl>
##  1 Ilyas, Yohan             1        21     0.42
##  2 Morgan, Terrance         2        17     0.34
##  3 Martin, Thomas           3        21     0.42
##  4 Clark, Frank             4        21     0.42
##  5 Riddhi, Karina           5        18     0.36
##  6 Andrew, Tyler            6        19     0.38
##  7 Julia                    7        19     0.38
##  8 Rachel, Lauren           8        11     0.22
##  9 Daniel, Caroline         9        15     0.3 
## 10 Josh, Maeve             10        17     0.34
## # ℹ 23 more rows

Stichprobenverteilung

library(tidyverse)
ggplot(tactile_prop_red, aes(x = prop_red)) +
  geom_histogram(binwidth = 0.05, boundary = 0.4,
                 color = "white") +
  scale_y_continuous(limits = c(0, 10), breaks = c(0:10)) +
  labs(x = "Anteil roter Kugeln aus insgesamt 50 (roten und weißen) Kugeln",
       y="Anzahl",
       title = "Verteilung von 33 Anteilswerten roter Kugeln")

Wahre Verteilung

Daten

bowl
## # A tibble: 2,400 × 2
##    ball_ID color
##      <int> <chr>
##  1       1 white
##  2       2 white
##  3       3 white
##  4       4 red  
##  5       5 white
##  6       6 white
##  7       7 red  
##  8       8 white
##  9       9 red  
## 10      10 white
## # ℹ 2,390 more rows

Anzahl und Anteil roter Kugeln

red_true <- bowl %>%
               summarize(Anzahl_rot = sum(color == "red"),
                     Anteil_rot = sum(color == "red")/length(color)
            )
red_true  %>%
    mutate(Anteil_rot=paste0(Anteil_rot*100,"%"))
## # A tibble: 1 × 2
##   Anzahl_rot Anteil_rot
##        <int> <chr>     
## 1        900 37.5%

(Virtuelles) Sampling und Punktschätzung

Unterschiedliche Schaufelgrößen

“Kleine Schaufel” (Stichprobengröße n = 25)

n <- 25
rep <- 1000
virtual_samples_25 <- bowl %>%
                        rep_sample_n(size = n,
                                     reps = rep)
virtual_samples_25
## # A tibble: 25,000 × 3
## # Groups:   replicate [1,000]
##    replicate ball_ID color
##        <int>   <int> <chr>
##  1         1    1139 red  
##  2         1    1121 white
##  3         1     627 red  
##  4         1    1717 red  
##  5         1    1143 white
##  6         1    1923 white
##  7         1     575 white
##  8         1    2341 white
##  9         1     799 white
## 10         1     452 red  
## # ℹ 24,990 more rows
virtual_prop_red_25 <- virtual_samples_25 %>%
                              group_by(replicate) %>%
                              summarize(red = sum(color == "red")) %>%
                              mutate(prop_red = red / n)
virtual_prop_red_25
## # A tibble: 1,000 × 3
##    replicate   red prop_red
##        <int> <int>    <dbl>
##  1         1    12     0.48
##  2         2     7     0.28
##  3         3    10     0.4 
##  4         4     8     0.32
##  5         5     7     0.28
##  6         6    11     0.44
##  7         7    12     0.48
##  8         8    12     0.48
##  9         9     9     0.36
## 10        10    11     0.44
## # ℹ 990 more rows
virtual_prop_red_25 %>% 
  ggplot(aes(x = prop_red)) +
      geom_histogram(binwidth = 0.05, boundary = 0.4, color = "white") +
      labs(x = paste0("Anteil roter Kugeln (aus ",n,")"),
           title = paste0("Kleine Schaufel (n=",n,")")) +
      geom_vline(xintercept = red_true$Anteil_rot,color='red')

“Mittlere Schaufel” (Stichprobengröße n = 50)

n <- 50
virtual_samples_50 <- bowl %>%
                         rep_sample_n(size = n,
                                      reps = rep)
virtual_prop_red_50 <- virtual_samples_50 %>%
                              group_by(replicate) %>%
                              summarize(red = sum(color == "red")) %>%
                              mutate(prop_red = red / n)
virtual_prop_red_50
## # A tibble: 1,000 × 3
##    replicate   red prop_red
##        <int> <int>    <dbl>
##  1         1    23     0.46
##  2         2    16     0.32
##  3         3    19     0.38
##  4         4    19     0.38
##  5         5    21     0.42
##  6         6    24     0.48
##  7         7    20     0.4 
##  8         8    13     0.26
##  9         9    23     0.46
## 10        10    13     0.26
## # ℹ 990 more rows
virtual_prop_red_50 %>% 
  ggplot(aes(x = prop_red)) +
      geom_histogram(binwidth = 0.05, boundary = 0.4, color = "white") +
      labs(x = paste0("Anteil roter Kugeln (aus ",n,")"),
           title = paste0("Kleine Schaufel (n=",n,")")) +
      geom_vline(xintercept = red_true$Anteil_rot,color='red')

“Große Schaufel” (Stichprobengröße n = 100)

n<-100
virtual_samples_100 <- bowl %>%
                          rep_sample_n(size = n,
                                       reps = rep)
virtual_samples_100
## # A tibble: 100,000 × 3
## # Groups:   replicate [1,000]
##    replicate ball_ID color
##        <int>   <int> <chr>
##  1         1    1264 white
##  2         1    1929 red  
##  3         1    1900 white
##  4         1     907 red  
##  5         1    1948 white
##  6         1    1366 white
##  7         1    1126 white
##  8         1    1122 white
##  9         1     309 white
## 10         1    2099 white
## # ℹ 99,990 more rows
virtual_prop_red_100 <- virtual_samples_100 %>%
                              group_by(replicate) %>%
                              summarize(red = sum(color == "red")) %>%
                              mutate(prop_red = red / n)
virtual_prop_red_100
## # A tibble: 1,000 × 3
##    replicate   red prop_red
##        <int> <int>    <dbl>
##  1         1    31     0.31
##  2         2    41     0.41
##  3         3    35     0.35
##  4         4    34     0.34
##  5         5    41     0.41
##  6         6    29     0.29
##  7         7    45     0.45
##  8         8    33     0.33
##  9         9    43     0.43
## 10        10    40     0.4 
## # ℹ 990 more rows
virtual_prop_red_100 %>% 
  ggplot(aes(x = prop_red)) +
      geom_histogram(binwidth = 0.05, boundary = 0.4, color = "white") +
      labs(x = paste0("Anteil roter Kugeln (aus ",n,")"),
           title = paste0("Kleine Schaufel (n=",n,")")) +
      geom_vline(xintercept = red_true$Anteil_rot,color='red')

Grundproblem der induktiven Statistik

\(\Rightarrow\) Bedeutung der Zufallsaufwahl bei der Datenerhebung (!)

Wenn der wahre Wert unbekannt ist

(Virtuelles) Ziehen einer Stichprobe

n <- 50
virtual_shovel <- bowl %>% 
                     rep_sample_n(size = n)
virtual_shovel
## # A tibble: 50 × 3
## # Groups:   replicate [1]
##    replicate ball_ID color
##        <int>   <int> <chr>
##  1         1     264 white
##  2         1    2244 white
##  3         1     519 white
##  4         1     352 red  
##  5         1     366 white
##  6         1     820 red  
##  7         1    1038 red  
##  8         1     633 red  
##  9         1    1298 white
## 10         1     947 white
## # ℹ 40 more rows

Anzahl und Anteil der roten Kugeln

virtual_shovel %>% 
  summarize(num_red = sum(color == "red")) %>% 
  mutate(prop_red = num_red /n)
## # A tibble: 1 × 3
##   replicate num_red prop_red
##       <int>   <int>    <dbl>
## 1         1      22     0.44

Statistische Inferenz

Stichprobenverteilung

Reliabilität und Validität

Stichprobenverteilungen…

…und wahrer Wert (rote Linien)

Vergleich der Standardfehler

virtual_prop_red_25 %>%
  summarize(sd = sd(prop_red))
## # A tibble: 1 × 1
##       sd
##    <dbl>
## 1 0.0943
virtual_prop_red_50 %>%
  summarize(sd = sd(prop_red))
## # A tibble: 1 × 1
##       sd
##    <dbl>
## 1 0.0710
virtual_prop_red_100 %>%
  summarize(sd = sd(prop_red))
## # A tibble: 1 × 1
##       sd
##    <dbl>
## 1 0.0484

Zentraler Grenzwertsatz

Mit zunehmendem Stichprobenumfang nähert sich (1) die Stichprobenverteilung eines Punktschätzers (bspw. Anteil roter Kugeln) einer Normalverteilung an und nimmt (2) die Streuung dieser Stichprobenverteilungen ab ( kleinere Standardfehler).

Die Normalverteilung der Stichprobenverteilung resultiert dabei unabhängig von der Verteilung in der Grundgesamtheit - solange die für die Stichproben jeweils berechneten Mittelwerte auf unabhängigen Zufallsvariablen basieren. Die Unabhängigkeit wird dabei durch die Zufälligkeit der Stichprobenziehung sichergestellt.

Beispiele, vgl. Skript Wahrscheinlichkeitstheorie & Zufallsvariablen

Mögliche Punktschätzer

Im bisher verwendeten Beispiel ging es um den Anteil roter Kugeln, mithin um die Schätzung eines Anteilswerts. Das Konzept der Stichprobenziehung kann jedoch auch zur Schätzung anderer Parameter einer Grundgesamtheit verwendet werden:

Mögliche Punktschätzer auf Basis von Stichproben
Fall Parameter der Grundgesamtheit Notation Punktschätzung Symbol(e)
1 Anteil in Grundgesamtheit \(p\) Anteil in Stichprobe \(\widehat{p}\)
2 Mittelwert der Grundgesamtheit \(\mu\) Stichprobenmittelwert \(\overline{x}\) oder \(\widehat{\mu}\)
3 Differenz von Anteilen einer Grundgesamtheit \(p_1 - p_2\) Differenz von Anteilen einer Stichprobe \(\widehat{p}_1 - \widehat{p}_2\)
4 Differenz von Mittelwerten der Grundgesamtheit \(\mu_1 - \mu_2\) Differenz von Stichprobenmittelwerten \(\overline{x}_1 - \overline{x}_2\) oder \(\widehat{\mu}_1 - \widehat{\mu}_2\)
5 Empirischer Regressionskoeffizient (Grundgesamtheit) \(\beta_1\) Angepasster (“fitted”) Regressionskoeffizient (Stichprobe) \(b_1\) oder \(\widehat{\beta}_1\)

Intervallschätzung und Konfidenzintervall

Punktschätzung vs. Intervallschätzung

Ermittlung von Konfidenzintervallen

Einzelne Stichprobe aus dem physischen Experiment

bowl_sample_1
## # A tibble: 50 × 1
##    color
##    <chr>
##  1 white
##  2 white
##  3 red  
##  4 red  
##  5 white
##  6 white
##  7 red  
##  8 white
##  9 white
## 10 white
## # ℹ 40 more rows
stats_sample_1 <- bowl_sample_1 %>%
                  summarize(Anzahl_rot=sum(color=='red'),
                            Anteil_rot=sum(color=='red')/
                                                length(color))
stats_sample_1
## # A tibble: 1 × 2
##   Anzahl_rot Anteil_rot
##        <int>      <dbl>
## 1         21       0.42

In der Stichprobe von Ilyas und Yohan befinden sich insgesamt 21 rote Kugeln, d.h. der Anteil roter Kugeln entspricht in ihrer Stichprobe 42%.

Nutzung der Funktionen im infer-Paket

Schritt 1: specify()

library(infer)
#bowl_sample_1 %>%        
#    specify(response = color)   # funktioniert nicht - "success" (also das "Ereignis A") muss definiert werden!

bowl_sample_1 %>%
    specify(response = color, success = "red")
## Response: color (factor)
## # A tibble: 50 × 1
##    color
##    <fct>
##  1 white
##  2 white
##  3 red  
##  4 red  
##  5 white
##  6 white
##  7 red  
##  8 white
##  9 white
## 10 white
## # ℹ 40 more rows

Schritt 2: generate()

bowl_sample_1 %>%
  specify(response = color, success = "red") %>%
  generate(reps = 1000, type = "bootstrap")
## Response: color (factor)
## # A tibble: 50,000 × 2
## # Groups:   replicate [1,000]
##    replicate color
##        <int> <fct>
##  1         1 red  
##  2         1 white
##  3         1 white
##  4         1 red  
##  5         1 white
##  6         1 white
##  7         1 white
##  8         1 white
##  9         1 white
## 10         1 white
## # ℹ 49,990 more rows

Schritt 3: calculate()

sample_1_bootstrap <- bowl_sample_1 %>%
                           specify(response = color,
                                   success = "red") %>%
                           generate(reps = 1000,
                                    type = "bootstrap") %>%
                           calculate(stat = "prop")
sample_1_bootstrap
## Response: color (factor)
## # A tibble: 1,000 × 2
##    replicate  stat
##        <int> <dbl>
##  1         1  0.38
##  2         2  0.42
##  3         3  0.38
##  4         4  0.52
##  5         5  0.52
##  6         6  0.48
##  7         7  0.44
##  8         8  0.4 
##  9         9  0.4 
## 10        10  0.32
## # ℹ 990 more rows

Schritt 4: visualize()

## # A tibble: 1 × 2
##   lower_ci upper_ci
##      <dbl>    <dbl>
## 1     0.28     0.56
sample_1_bootstrap %>%
        visualize(bins = 15) +
        shade_confidence_interval(endpoints = percentile_ci_1) +
        geom_vline(xintercept = 0.42, linetype = "dashed")

Interpretation Konfidenzintervall

Perzentil-Methode

Standardfehler-Methode

Stichprobenverteilung vs. Bootstrap-Verteilung

Stichprobenverteilung

## # A tibble: 1 × 1
##       se
##    <dbl>
## 1 0.0662

Bootstrapping-Verteilung

## # A tibble: 1 × 1
##       se
##    <dbl>
## 1 0.0714